home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / Date.sml < prev    next >
Encoding:
Text File  |  1997-08-18  |  6.0 KB  |  176 lines  |  [TEXT/R*ch]
  1. (* Date -- 1995-07-03 *)
  2.  
  3. datatype weekday = Mon | Tue | Wed | Thu | Fri | Sat | Sun
  4.  
  5. datatype month
  6.   = Jan | Feb | Mar | Apr | May | Jun
  7.   | Jul | Aug | Sep | Oct | Nov | Dec
  8.  
  9. datatype date = DATE of {
  10.     year   : int,            (* e.g. 1995 *)
  11.     month  : month,
  12.     day    : int,               (* 1-31  *)
  13.     hour   : int,               (* 0-23  *)
  14.     minute : int,               (* 0-59  *)
  15.     second : int,               (* 0-61 (allowing for leap seconds) *)
  16.     wday   : weekday option,
  17.     yday   : int option,        (* 0-365 *)
  18.     isDst  : bool option        (* daylight savings time in force *)
  19.   }
  20.  
  21. exception Date
  22.  
  23. local 
  24.     type tmoz = {tm_hour   : int,
  25.          tm_isdst  : int,    (* 0 = no, 1 = yes, ~1 = don't know *)
  26.          tm_mday   : int,
  27.          tm_min    : int,
  28.          tm_mon    : int,
  29.          tm_sec    : int, 
  30.          tm_wday   : int,
  31.          tm_yday   : int,
  32.          tm_year   : int
  33.          }
  34.  
  35.     prim_val getlocaltime_ : real -> tmoz = 1 "sml_localtime";
  36.     prim_val getunivtime_  : real -> tmoz = 1 "sml_gmtime";
  37.     prim_val mktime_       : tmoz -> real = 1 "sml_mktime";
  38.  
  39.     prim_val asctime_  : tmoz -> string           = 1 "sml_asctime";
  40.     prim_val strftime_ : string -> tmoz -> string = 2 "sml_strftime";
  41.  
  42.     val toweekday = fn 0 => Sun | 1 => Mon | 2 => Tue | 3 => Wed
  43.                      | 4 => Thu | 5 => Fri | 6 => Sat 
  44.              | _ => raise Fail "Internal error: Date.toweekday";
  45.     val fromwday  = fn Sun => 0 | Mon => 1 | Tue => 2 | Wed => 3 
  46.                      | Thu => 4 | Fri => 5 | Sat => 6;
  47.     val tomonth   = fn 0 => Jan | 1 => Feb |  2 => Mar |  3 => Apr
  48.                      | 4 => May | 5 => Jun |  6 => Jul |  7 => Aug
  49.              | 8 => Sep | 9 => Oct | 10 => Nov | 11 => Dec
  50.              | _ => raise Fail "Internal error: Date.tomonth";
  51.     val frommonth = fn Jan => 0 | Feb => 1 | Mar => 2  | Apr => 3
  52.              | May => 4 | Jun => 5 | Jul => 6  | Aug => 7
  53.              | Sep => 8 | Oct => 9 | Nov => 10 | Dec => 11;
  54.     
  55.     fun tmozToDate {tm_hour, tm_isdst, tm_mday, tm_min, tm_mon, tm_sec,
  56.             tm_wday, tm_yday, tm_year} = 
  57.     DATE {year = tm_year + 1900, month = tomonth tm_mon, 
  58.           day = tm_mday, hour = tm_hour, minute = tm_min, 
  59.           second = tm_sec, wday = SOME (toweekday tm_wday),
  60.           yday = SOME tm_yday, 
  61.           isDst = case tm_isdst of 0 => SOME false 
  62.                                  | 1 => SOME true
  63.                                      | _ => NONE}
  64.  
  65.     fun okDate (DATE {year, month, day, hour, minute, second, yday, ...}) =
  66.     let fun leap y = 
  67.             y mod 4 = 0 andalso y mod 100 <> 0 orelse y mod 400 = 0;
  68.         val mthdays = fn Jan => 31 | Feb => if leap year then 29 else 28
  69.                     | Mar => 31 | Apr => 30 | May => 31 | Jun => 30
  70.             | Jul => 31 | Aug => 31 | Sep => 30 | Oct => 31
  71.             | Nov => 30 | Dec => 31;
  72.         val yeardays = if leap year then 366 else 365
  73.     in 
  74.              1900 <= year 
  75.             andalso 1 <= day    andalso day    <= mthdays month
  76.         andalso 0 <= hour   andalso hour   <= 23
  77.         andalso 0 <= minute andalso minute <= 59
  78.         andalso 0 <= second andalso second <= 61 (* leap seconds *)
  79.         andalso case yday of
  80.                  NONE    => true
  81.            | SOME yd => 0 <= yd andalso yd < yeardays
  82.     end;
  83.  
  84.     fun dateToTmoz (dt as DATE {year, month, day, hour, minute, second,
  85.                    wday, yday, isDst}) =
  86.     if okDate dt then 
  87.         {tm_hour = hour, tm_mday = day, tm_min = minute, 
  88.          tm_mon = frommonth month, tm_sec = second, 
  89.          tm_year = year - 1900, 
  90.          tm_isdst = case isDst of SOME false=>0 | SOME true=>1 | NONE=> ~1,
  91.           tm_wday = case wday of SOME w => fromwday w | NONE => 0,
  92.          tm_yday = case yday of SOME y => y | NONE => 0} 
  93.     else
  94.         raise Date;
  95.  
  96. in
  97.  
  98.     fun fromTime t = tmozToDate (getlocaltime_ (Time.toReal t));
  99.  
  100.     fun fromUTC t  = tmozToDate (getunivtime_ (Time.toReal t));
  101.  
  102.     (* The following implements conversion from a local date to 
  103.        a Time.time.  It IGNORES wday and yday.  *)
  104.  
  105.     fun toTime date = 
  106.     let val clock = mktime_ (dateToTmoz date)
  107.     in
  108.         if clock < 0.0 then raise Date
  109.         else Time.fromReal clock
  110.     end;
  111.  
  112.     fun toString date =
  113.     String.substring(asctime_ (dateToTmoz date), 0, 24) 
  114.     handle Fail _    => raise Date
  115.          | Subscript => raise (Fail "Date.toString: internal error");
  116.  
  117.     fun fmt fmtstr date =
  118.     (strftime_ fmtstr (dateToTmoz date)) 
  119.     handle Fail _ => raise Date
  120.  
  121.     (* To scan dates in the format "Wed Mar  8 19:06:45 1995" *)
  122.  
  123.     exception BadFormat;
  124.     fun getVal (SOME v) = v
  125.       | getVal NONE     = raise BadFormat;
  126.     
  127.     fun scan getc src =
  128.     let val getstring  = StringCvt.splitl Char.isAlpha getc
  129.     fun getint src = getVal (Int.scan StringCvt.DEC getc src)
  130.     fun drop p     = StringCvt.dropl p getc
  131.     fun isColon c  = (c = #":")
  132.  
  133.     val getMonth = fn "Jan" => Jan | "Feb" => Feb | "Mar" => Mar
  134.                      | "Apr" => Apr | "May" => May | "Jun" => Jun
  135.              | "Jul" => Jul | "Aug" => Aug | "Sep" => Sep
  136.              | "Oct" => Oct | "Nov" => Nov | "Dec" => Dec 
  137.              | _ => raise BadFormat
  138.     val getWday  = fn "Sun" => Sun | "Mon" => Mon | "Tue" => Tue
  139.              | "Wed" => Wed | "Thu" => Thu | "Fri" => Fri
  140.              | "Sat" => Sat 
  141.              | _ => raise BadFormat
  142.  
  143.     val (wday, src1)  = getstring src
  144.     val (month, src2) = getstring (drop Char.isSpace src1)
  145.     val (day, src3)   = getint src2
  146.     val (hour, src4)  = getint src3
  147.     val (min, src5)   = getint (drop isColon src4)
  148.     val (sec, src6)   = getint (drop isColon src5)
  149.     val (year, src7)  = getint src6
  150.     in SOME (DATE {year = year, month = getMonth month, 
  151.            day = day,  hour = hour, minute = min, 
  152.            second = sec, wday = SOME (getWday wday), 
  153.            yday = NONE, isDst = NONE}, src7) 
  154.     end
  155.     handle BadFormat => NONE
  156.  
  157.     fun fromString s = StringCvt.scanString scan s
  158.  
  159.     fun compare 
  160.     (DATE {year=y1,month=mo1,day=d1,hour=h1,minute=mi1,second=s1, ...},
  161.      DATE {year=y2,month=mo2,day=d2,hour=h2,minute=mi2,second=s2, ...}) =
  162.     let fun cmp(v1, v2, cmpnext) = 
  163.         if v1 < v2 then LESS 
  164.         else if v1 > v2 then GREATER
  165.         else (* EQUAL *) cmpnext ()
  166.     in 
  167.         cmp(y1, y2, 
  168.         fn _ => cmp(frommonth mo1, frommonth mo2, 
  169.         fn _ => cmp(d1, d2,         
  170.         fn _ => cmp(h1, h2,
  171.         fn _ => cmp(mi1, mi2,
  172.         fn _ => cmp(s1, s2,
  173.         fn _ => EQUAL))))))
  174.     end
  175. end
  176.